home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
c
/
num_log.c
< prev
next >
Wrap
C/C++ Source or Header
|
1987-06-04
|
17KB
|
926 lines
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
Logical operations on number
*/
#include "include.h"
#include "num_include.h"
/*
x : fixnum or bignum (may be not normalized)
y : integer
returns
fixnum or bignum ( not normalized )
*/
object
log_op(op)
int (*op)();
{
object x;
int narg, i, j;
struct bignum *big_log_op();
narg = vs_top - vs_base;
if (narg < 2) too_few_arguments();
i = narg;
while(--i >= 0)
if (type_of(vs_base[i]) == t_bignum) goto BIG_OP;
j = fix(vs_base[0]);
i = 1;
while (i < narg) {
j = (*op)(j, fix(vs_base[i]));
i++;
}
return(make_fixnum(j));
BIG_OP:
x = (object)copy_to_big(vs_base[0]);
vs_push(x);
i = 1;
while (i < narg) {
x = (object)big_log_op(x, vs_base[i], op);
i++;
}
x = normalize_big_to_object(x);
vs_pop;
return(x);
}
/*
big_log_op(x, y, op) performs the logical operation op onto
x and y, and return the result in x destructively.
*/
struct bignum *
big_log_op(x, y, op)
struct bignum *x;
object y;
int (*op)();
{
struct bignum *r;
int sign_x, sign_y;
int ext_x, ext_y;
int end_x, end_y;
int i, j;
r = x; /* remember start of x */
if (type_of(x) != t_bignum)
FEwrong_type_argument(Sbignum, x);
else if (big_sign(x) < 0) {
sign_x = ~MASK;
ext_x = MASK;
} else
sign_x = ext_x = 0;
if (type_of(y) == t_fixnum)
if (fix(y) < 0) {
sign_y = ~MASK;
ext_y = MASK;
} else
sign_y = ext_y = 0;
else if (type_of(y) == t_bignum)
if (big_sign(y) < 0) {
sign_y = ~MASK;
ext_y = MASK;
} else
sign_y = ext_y = 0;
else
FEwrong_type_argument(Sinteger, y);
end_x = end_y = 0;
while ((end_x == 0) || (end_y == 0)) {
if (end_x == 0)
i = (x->big_car) & MASK;
else
i = ext_x;
if (end_y == 0)
if (type_of(y) == t_fixnum)
j = (fix(y)) & MASK;
else
j = (y->big.big_car) & MASK;
else
j = ext_y;
i = (*op)(i, j);
if (end_x == 0)
x->big_car = i & MASK;
else
x = stretch_big(x, i & MASK);
if (x->big_cdr != NULL)
x = x->big_cdr;
else
end_x = 1;
if (type_of(y) == t_fixnum)
end_y = 1;
else if (y->big.big_cdr != 0)
y = (object)y->big.big_cdr;
else
end_y = 1;
}
/* Now x points ths last sell of bignum.
We must set the sign bit according to operation.
Sign bit of x is already masked out in previous
while-iteration */
x->big_car |= ((*op)(sign_x, sign_y) & ~MASK);
return(r);
}
int
ior_op(i, j)
int i, j;
{
return(i | j);
}
int
xor_op(i, j)
int i, j;
{
return(i ^ j);
}
int
and_op(i, j)
int i, j;
{
return(i & j);
}
int
eqv_op(i, j)
int i, j;
{
return(~(i ^ j));
}
int
nand_op(i, j)
int i, j;
{
return(~(i & j));
}
int
nor_op(i, j)
int i, j;
{
return(~(i | j));
}
int
andc1_op(i, j)
int i, j;
{
return((~i) & j);
}
int
andc2_op(i, j)
int i, j;
{
return(i & (~j));
}
int
orc1_op(i, j)
int i, j;
{
return((~i) | j);
}
int
orc2_op(i, j)
int i, j;
{
return(i | (~j));
}
b_clr_op(i, j)
int i, j;
{
return(0);
}
b_set_op(i, j)
int i, j;
{
return(-1);
}
b_1_op(i, j)
int i, j;
{
return(i);
}
b_2_op(i, j)
int i, j;
{
return(j);
}
b_c1_op(i, j)
int i, j;
{
return(~i);
}
b_c2_op(i, j)
int i, j;
{
return(~j);
}
int
big_bitp(x, p)
object x;
int p;
{
int sign, cell, bit, i;
if (p >= 0) {
cell = p / 31;
bit = p % 31;
while (cell-- > 0) {
if (x->big.big_cdr != NULL)
x = (object)x->big.big_cdr;
else if (x->big.big_car < 0)
return(1);
else
return(0);
}
return((x->big.big_car >> bit) & 1);
} else
return(0);
}
int
fix_bitp(x, p)
object x;
int p;
{
if (p > 30) /* fix = sign + bit0-30 */
if (fix(x) < 0)
return(1);
else
return(0);
return((fix(x) >> p) & 1);
}
int
count_int_bits(x)
int x;
{
int i, count;
count = 0;
for (i=0; i < 31; i++) count += ((x >> i) & 1);
return(count);
}
int
count_bits(x)
object x;
{
int i, count, sign;
if (type_of(x) == t_fixnum) {
i = fix(x);
if (i < 0) i = ~i;
count = count_int_bits(i);
} else if (type_of(x) == t_bignum) {
count = 0;
sign = big_sign(x);
for (;;) {
i = x->big.big_car;
if (sign < 0) i = ~i & MASK;
count += count_int_bits(i);
if (x->big.big_cdr == NULL) break;
x = (object)x->big.big_cdr;
}
} else
FEwrong_type_argument(Sinteger, x);
return(count);
}
/*
double_shift(h, l, w, hp, lp) shifts the int h & l ( 31 bits)
w bits to left ( w > 0) or to right ( w < 0).
result is returned in *hp and *lp.
*/
double_shift(h, l, w, hp, lp)
int h, l, w, *hp, *lp;
{
if (w >= 0) {
*lp = (l << w) & MASK;
*hp = ((h << w) & MASK) | ((l & MASK) >> (31 - w));
} else {
w = -w;
*hp = (h & MASK) >> w;
*lp = ((h << (31 - w)) & MASK) | ((l & MASK) >> w);
}
}
object
shift_integer(x, w)
object x;
int w;
{
struct bignum *y, *y0;
object r;
int cell, bits, sign, i;
int ext, h, l, nh, nl, end_x;
vs_mark;
cell = w / 31;
bits = w % 31;
if (type_of(x) == t_fixnum) {
i = fix(x);
if (cell == 0) {
if (w < 0) {
if (i >= 0)
return(make_fixnum(i >> -w));
else
return(make_fixnum(~((~i) >> -w)));
} if (i >= 0) {
if (((-1<<(31-w)) & i) == 0)
/* if (((~MASK >> w) & i) == 0) */
return(make_fixnum(i << w));
} else {
if (w < 32 && ((-1<<(31-w)) & ~i) == 0)
/* if (w < 32 && ((~MASK >> w) & ~i) == 0) */
return(make_fixnum(i << w));
}
}
x = alloc_object(t_bignum);
x->big.big_car = i;
x->big.big_cdr = NULL;
vs_push(x);
}
if ((sign = big_sign(x)) < 0)
ext = MASK;
else
ext = 0;
y = y0 = (struct bignum *)alloc_object(t_bignum);
y->big_car = 0;
y->big_cdr = NULL;
vs_push(((object)y0));
if (w < 0) goto RIGHT;
LEFT:
while (cell-- > 0)
y = stretch_big(y, 0);
l = 0;
h = x->big.big_car;
end_x = 0;
goto COMMON;
RIGHT:
end_x = 0;
h = x->big.big_car;
while (cell++ <= 0) {
l = h;
if (end_x == 1) break;
if (x->big.big_cdr != NULL) {
x = (object)x->big.big_cdr;
h = x->big.big_car;
} else {
end_x = 1;
h = ext;
}
}
COMMON:
for (;;) {
double_shift(h, l, bits, &nh, &nl);
if (w < 0)
y->big_car = nl;
else
y->big_car = nh;
if (end_x == 1) break;
l = h;
if (x->big.big_cdr != NULL) {
x = (object)x->big.big_cdr;
h = x->big.big_car;
} else {
h = ext;
end_x = 1;
}
y = stretch_big(y, 0);
}
/* set sign bit */
if (sign < 0) y->big_car |= ~MASK;
r = normalize_big_to_object(y0);
vs_reset;
return(r);
}
int
int_bit_length(i)
int i;
{
int count, j;
count = 0;
for (j = 0; j < 31 ; j++)
if (((i >> j) & 1) == 1) count = j + 1;
return(count);
}
Llogior()
{
object x;
int narg, i;
int ior_op();
narg = vs_top - vs_base;
for (i = 0; i < narg; i++)
check_type_integer(&vs_base[i]);
if (narg == 0) {
vs_top = vs_base;
vs_push(small_fixnum(0));
return;
}
if (narg == 1)
return;
x = log_op(ior_op);
vs_top = vs_base;
vs_push(x);
}
Llogxor()
{
object x;
int narg, i;
int xor_op();
narg = vs_top - vs_base;
for (i = 0; i < narg; i++)
check_type_integer(&vs_base[i]);
if (narg == 0) {
vs_top = vs_base;
vs_push(small_fixnum(0));
return;
}
if (narg == 1) return;
x = log_op(xor_op);
vs_top = vs_base;
vs_push(x);
}
Llogand()
{
object x;
int narg, i;
int and_op();
narg = vs_top - vs_base;
for (i = 0; i < narg; i++)
check_type_integer(&vs_base[i]);
if (narg == 0) {
vs_top = vs_base;
vs_push(small_fixnum(-1));
return;
}
if (narg == 1) return;
x = log_op(and_op);
vs_top = vs_base;
vs_push(x);
}
Llogeqv()
{
object x;
int narg, i;
int eqv_op();
narg = vs_top - vs_base;
for (i = 0; i < narg; i++)
check_type_integer(&vs_base[i]);
if (narg == 0) {
vs_top = vs_base;
vs_push(small_fixnum(-1));
return;
}
if (narg == 1) return;
x = log_op(eqv_op);
vs_top = vs_base;
vs_push(x);
}
Lboole()
{
object x;
object o, r;
int (*op)();
check_arg(3);
check_type_integer(&vs_base[0]);
check_type_integer(&vs_base[1]);
check_type_integer(&vs_base[2]);
o = vs_base[0];
switch(fixint(o)) {
case BOOLCLR: op = b_clr_op; break;
case BOOLSET: op = b_set_op; break;
case BOOL1: op = b_1_op; break;
case BOOL2: op = b_2_op; break;
case BOOLC1: op = b_c1_op; break;
case BOOLC2: op = b_c2_op; break;
case BOOLAND: op = and_op; break;
case BOOLIOR: op = ior_op; break;
case BOOLXOR: op = xor_op; break;
case BOOLEQV: op = eqv_op; break;
case BOOLNAND: op = nand_op; break;
case BOOLNOR: op = nor_op; break;
case BOOLANDC1: op = andc1_op; break;
case BOOLANDC2: op = andc2_op; break;
case BOOLORC1: op = orc1_op; break;
case BOOLORC2: op = orc2_op; break;
default:
FEerror("~S is an invalid logical operator.",
1, o);
}
vs_base++;
x = log_op(op);
vs_base--;
vs_top = vs_base;
vs_push(x);
}
Llogbitp()
{
object x, p;
int i;
check_arg(2);
check_type_integer(&vs_base[0]);
check_type_integer(&vs_base[1]);
p = vs_base[0];
x = vs_base[1];
if (type_of(p) == t_fixnum)
if (type_of(x) == t_fixnum)
i = fix_bitp(x, fix(p));
else
i = big_bitp(x, fix(p));
else if (big_sign(p) < 0)
i = 0;
/*
bit position represented by bignum is out of
our address space. So, result is returned
according to sign of integer.
*/
else if (type_of(x) == t_fixnum)
if (fix(x) < 0)
i = 1;
else
i = 0;
else if (big_sign(x) < 0)
i = 1;
else
i = 0;
vs_top = vs_base;
if (i == 1)
vs_push(Ct);
else
vs_push(Cnil);
}
Lash()
{
object r, x, y;
int w, sign_x;
check_arg(2);
check_type_integer(&vs_base[0]);
check_type_integer(&vs_base[1]);
x = vs_base[0];
y = vs_base[1];
if (type_of(y) == t_fixnum) {
w = fix(y);
r = shift_integer(x, w);
} else if (type_of(y) == t_bignum)
goto LARGE_SHIFT;
else
;
goto BYE;
/*
bit position represented by bignum is probably
out of our address space. So, result is returned
according to sign of integer.
*/
LARGE_SHIFT:
if (type_of(x) == t_fixnum)
if (fix(x) > 0)
sign_x = 1;
else if (fix(x) == 0)
sign_x = 0;
else
sign_x = -1;
else
sign_x = big_sign(x);
if (big_sign(y) < 0)
if (sign_x < 0)
r = small_fixnum(-1);
else
r = small_fixnum(0);
else if (sign_x == 0)
r = small_fixnum(0);
else
FEerror("Insufficient memory.", 0);
BYE:
vs_top = vs_base;
vs_push(r);
}
Llogcount()
{
object x;
int i;
check_arg(1);
check_type_integer(&vs_base[0]);
x = vs_base[0];
i = count_bits(x);
vs_top = vs_base;
vs_push(make_fixnum(i));
}
Linteger_length()
{
object x;
int count, cell, i;
check_arg(1);
check_type_integer(&vs_base[0]);
x = vs_base[0];
if (type_of(x) == t_fixnum) {
i = fix(x);
if (i < 0) i = ~i;
count = int_bit_length(i);
} else if (type_of(x) == t_bignum) {
cell = 0;
while(x->big.big_cdr != NULL) {
cell++;
x = (object)x->big.big_cdr;
}
i = x->big.big_car;
if (i < 0) i = ~i;
count = cell * 31 + int_bit_length(i);
} else
;
vs_top = vs_base;
vs_push(make_fixnum(count));
}
object Sbit;
init_num_log()
{
int siLbit_array_op();
make_constant("BOOLE-CLR", make_fixnum(BOOLCLR));
make_constant("BOOLE-SET", make_fixnum(BOOLSET));
make_constant("BOOLE-1", make_fixnum(BOOL1));
make_constant("BOOLE-2", make_fixnum(BOOL2));
make_constant("BOOLE-C1", make_fixnum(BOOLC1));
make_constant("BOOLE-C2", make_fixnum(BOOLC2));
make_constant("BOOLE-AND", make_fixnum(BOOLAND));
make_constant("BOOLE-IOR", make_fixnum(BOOLIOR));
make_constant("BOOLE-XOR", make_fixnum(BOOLXOR));
make_constant("BOOLE-EQV", make_fixnum(BOOLEQV));
make_constant("BOOLE-NAND", make_fixnum(BOOLNAND));
make_constant("BOOLE-NOR", make_fixnum(BOOLNOR));
make_constant("BOOLE-ANDC1", make_fixnum(BOOLANDC1));
make_constant("BOOLE-ANDC2", make_fixnum(BOOLANDC2));
make_constant("BOOLE-ORC1", make_fixnum(BOOLORC1));
make_constant("BOOLE-ORC2", make_fixnum(BOOLORC2));
make_function("LOGIOR", Llogior);
make_function("LOGXOR", Llogxor);
make_function("LOGAND", Llogand);
make_function("LOGEQV", Llogeqv);
make_function("BOOLE", Lboole);
make_function("LOGBITP", Llogbitp);
make_function("ASH", Lash);
make_function("LOGCOUNT", Llogcount);
make_function("INTEGER-LENGTH", Linteger_length);
Sbit = make_ordinary("BIT");
make_si_function("BIT-ARRAY-OP", siLbit_array_op);
}
siLbit_array_op()
{
int i, j, n, d;
object o, x, y, r, r0;
int (*op)();
bool replace = FALSE;
int xi, yi, ri;
char *xp, *yp, *rp;
int xo, yo, ro;
object *base = vs_base;
check_arg(4);
o = vs_base[0];
x = vs_base[1];
y = vs_base[2];
r = vs_base[3];
if (type_of(x) == t_bitvector) {
d = x->bv.bv_dim;
xp = x->bv.bv_self;
xo = x->bv.bv_offset;
if (type_of(y) != t_bitvector)
goto ERROR;
if (d != y->bv.bv_dim)
goto ERROR;
yp = y->bv.bv_self;
yo = y->bv.bv_offset;
if (r == Ct)
r = x;
if (r != Cnil) {
if (type_of(r) != t_bitvector)
goto ERROR;
if (r->bv.bv_dim != d)
goto ERROR;
i = (r->bv.bv_self - xp)*8 + (r->bv.bv_offset - xo);
if (i > 0 && i < d || i < 0 && -i < d) {
r0 = r;
r = Cnil;
replace = TRUE;
goto L1;
}
i = (r->bv.bv_self - yp)*8 + (r->bv.bv_offset - yo);
if (i > 0 && i < d || i < 0 && -i < d) {
r0 = r;
r = Cnil;
replace = TRUE;
}
}
L1:
if (r == Cnil) {
vs_base = vs_top;
vs_push(Sbit);
vs_push(make_fixnum(d));
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
siLmake_vector();
r = vs_base[0];
}
} else {
if (type_of(x) != t_array)
goto ERROR;
if ((enum aelttype)x->a.a_elttype != aet_bit)
goto ERROR;
d = x->a.a_dim;
xp = x->bv.bv_self;
xo = x->bv.bv_offset;
if (type_of(y) != t_array)
goto ERROR;
if ((enum aelttype)y->a.a_elttype != aet_bit)
goto ERROR;
if (x->a.a_rank != y->a.a_rank)
goto ERROR;
yp = y->bv.bv_self;
yo = y->bv.bv_offset;
for (i = 0; i < x->a.a_rank; i++)
if (x->a.a_dims[i] != y->a.a_dims[i])
goto ERROR;
if (r == Ct)
r = x;
if (r != Cnil) {
if (type_of(r) != t_array)
goto ERROR;
if ((enum aelttype)r->a.a_elttype != aet_bit)
goto ERROR;
if (r->a.a_rank != x->a.a_rank)
goto ERROR;
for (i = 0; i < x->a.a_rank; i++)
if (r->a.a_dims[i] != x->a.a_dims[i])
goto ERROR;
i = (r->bv.bv_self - xp)*8 + (r->bv.bv_offset - xo);
if (i > 0 && i < d || i < 0 && -i < d) {
r0 = r;
r = Cnil;
replace = TRUE;
goto L2;
}
i = (r->bv.bv_self - yp)*8 + (r->bv.bv_offset - yo);
if (i > 0 && i < d || i < 0 && -i < d) {
r0 = r;
r = Cnil;
replace = TRUE;
}
}
L2:
if (r == Cnil) {
vs_base = vs_top;
vs_push(Sbit);
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
for (i = 0; i < x->a.a_rank; i++)
vs_push(make_fixnum(x->a.a_dims[i]));
siLmake_pure_array();
r = vs_base[0];
}
}
rp = r->bv.bv_self;
ro = r->bv.bv_offset;
switch(fixint(o)) {
case BOOLCLR: op = b_clr_op; break;
case BOOLSET: op = b_set_op; break;
case BOOL1: op = b_1_op; break;
case BOOL2: op = b_2_op; break;
case BOOLC1: op = b_c1_op; break;
case BOOLC2: op = b_c2_op; break;
case BOOLAND: op = and_op; break;
case BOOLIOR: op = ior_op; break;
case BOOLXOR: op = xor_op; break;
case BOOLEQV: op = eqv_op; break;
case BOOLNAND: op = nand_op; break;
case BOOLNOR: op = nor_op; break;
case BOOLANDC1: op = andc1_op; break;
case BOOLANDC2: op = andc2_op; break;
case BOOLORC1: op = orc1_op; break;
case BOOLORC2: op = orc2_op; break;
default:
FEerror("~S is an invalid logical operator.", 1, o);
}
#define set_high(place, nbits, value) \
((place)=((place)&~(-0400>>(nbits))|(value)&(-0400>>(nbits))))
#define set_low(place, nbits, value) \
((place)=((place)&(-0400>>(8-(nbits)))|(value)&~(-0400>>(8-(nbits)))))
#define extract_byte(integer, pointer, index, offset) \
(integer) = (pointer)[(index)+1] & 0377; \
(integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset)))
#define store_byte(pointer, index, offset, value) \
set_low((pointer)[index], 8-(offset), (value)>>(offset)); \
set_high((pointer)[(index)+1], offset, (value)<<(8-(offset)))
if (xo == 0 && yo == 0 && ro == 0) {
for (n = d/8, i = 0; i < n; i++)
rp[i] = (*op)(xp[i], yp[i]);
if ((j = d%8) > 0)
set_high(rp[n], j, (*op)(xp[n], yp[n]));
if (!replace) {
vs_top = vs_base = base;
vs_push(r);
return;
}
} else {
for (n = d/8, i = 0; i <= n; i++) {
extract_byte(xi, xp, i, xo);
extract_byte(yi, yp, i, yo);
if (i == n) {
if ((j = d%8) == 0)
break;
extract_byte(ri, rp, n, ro);
set_high(ri, j, (*op)(xi, yi));
} else
ri = (*op)(xi, yi);
store_byte(rp, i, ro, ri);
}
if (!replace) {
vs_top = vs_base = base;
vs_push(r);
return;
}
}
rp = r0->bv.bv_self;
ro = r0->bv.bv_offset;
for (n = d/8, i = 0; i <= n; i++) {
if (i == n) {
if ((j = d%8) == 0)
break;
extract_byte(ri, rp, n, ro);
set_high(ri, j, r->bv.bv_self[n]);
} else
ri = r->bv.bv_self[i];
store_byte(rp, i, ro, ri);
}
vs_top = vs_base = base;
vs_push(r0);
return;
ERROR:
FEerror("Illegal arguments for bit-array operation.", 0);
}